Attribute VB_Name = "mdlFunctions"
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long
Private Type POINTAPI
        x As Long
        y As Long
End Type

Private Type BLENDFUNCTION
  BlendOp As Byte
  BlendFlags As Byte
  SourceConstantAlpha As Byte
  AlphaFormat As Byte
End Type
' BlendOp:
Private Const AC_SRC_OVER = &H0
' AlphaFormat:
Private Const AC_SRC_ALPHA = &H1

Private Declare Function AlphaBlend Lib "MSIMG32.dll" ( _
  ByVal hdcDest As Long, _
  ByVal nXOriginDest As Long, _
  ByVal nYOriginDest As Long, _
  ByVal nWidthDest As Long, _
  ByVal nHeightDest As Long, _
  ByVal hdcSrc As Long, _
  ByVal nXOriginSrc As Long, _
  ByVal nYOriginSrc As Long, _
  ByVal nWidthSrc As Long, _
  ByVal nHeightSrc As Long, _
  ByVal lBlendFunction As Long _
) As Long

Public Enum enumOpStyle
 osBlend = 0
 osMax = 1
 osMin = 2
 osHalf = 3
 osBuildAlphaChannel_UseBlackForTransColor = 4
 osBuildAlphaChannel_UseWhiteForTransColor = 5
 osGammaCorrection = 6
 osGammaCorrectionEx = 7
End Enum

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private WPath As String, sPath As String

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2

Public Enum DrawTextConstants
 DT_BOTTOM = &H8
 DT_CALCRECT = &H400
 DT_CENTER = &H1
 DT_EXPANDTABS = &H40
 DT_EXTERNALLEADING = &H200
 DT_INTERNAL = &H1000
 DT_LEFT = &H0
 DT_NOCLIP = &H100
 DT_NOPREFIX = &H800
 DT_RIGHT = &H2
 DT_SINGLELINE = &H20
 DT_TABSTOP = &H80
 DT_TOP = &H0
 DT_VCENTER = &H4
 DT_WORDBREAK = &H10
End Enum

Private Declare Function TransparentBlt Lib "MSIMG32.dll" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Long
Private Const ECM_FIRST = &H1500                    '// Edit control messages

Private Const EM_SETCUEBANNER = (ECM_FIRST + 1)
Private Const EM_GETCUEBANNER = (ECM_FIRST + 2)     '// Set the cue banner with the lParm = LPCWSTR

Private Type EDITBALLOONTIP
    cbStruct As Long
    pszTitle As Long
    pszText As Long
    ttiIcon As Long ' ; // From TTI_*
End Type

Private Const EM_SHOWBALLOONTIP = (ECM_FIRST + 3)      '// Show a balloon tip associated to the edit control
Private Const EM_HIDEBALLOONTIP = (ECM_FIRST + 4)       '// Hide any balloon tip associated with the edit control

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Enum BalloonTipIconConstants
   TTI_NONE = 0
   TTI_INFO = 1
   TTI_WARNING = 2
   TTI_ERROR = 3
End Enum

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long

Public Function CreateAlphaImage(m_cImage As cAlphaDibSection, m_cMask As cAlphaDibSection) As cAlphaDibSection
On Error GoTo a
Dim m_cAlphaImage As New cAlphaDibSection
   ' Load picture:
   'm_cImage.CreateFromPicture LoadPicture(App.Path & "\logo.bmp")
   
   ' Load alpha channel:
   'm_cMask.CreateFromPicture LoadPicture(App.Path & "\logomask.bmp")
   
   ' Create a new image, which is just a copy of the picture
   ' in m_cImage to build the alpha version in.  Note if
   ' we didn't want to display the image without alpha later,
   ' we could just work on m_cImage directly instead.
   m_cAlphaImage.Create m_cImage.Width, m_cImage.Height
   m_cImage.PaintPicture m_cAlphaImage.hDC
   
   ' Point byte arrays at the image bits for ease of
   ' manipulation of the data:
   Dim tMask As SAFEARRAY2D
   Dim bMask() As Byte
   Dim tImage As SAFEARRAY2D
   Dim bImage() As Byte
    
    With tMask
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cMask.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cMask.BytesPerScanLine()
        .pvData = m_cMask.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bMask()), VarPtr(tMask), 4
    
    With tImage
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = m_cAlphaImage.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = m_cAlphaImage.BytesPerScanLine()
        .pvData = m_cAlphaImage.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
   
   Dim x As Long, y As Long
   Dim bAlpha As Long
   For y = 0 To m_cAlphaImage.Height - 1
      For x = 0 To m_cAlphaImage.BytesPerScanLine - 4 Step 4 ' each item has 4 bytes: R,G,B,A
         ' Get the red Value from the mask to use as the alpha
         ' Value:
         bAlpha = bMask(x, y)
         ' Set the alpha in the alpha image..
         bImage(x + 3, y) = bAlpha
         ' Now premultiply the r/g/b Values by the alpha divided
         ' by 255.  This is required for the AlphaBlend GDI function,
         ' see MSDN/Platform SDK/GDI/BLENDFUNCTION for more
         ' details:
         bImage(x, y) = bImage(x, y) * bAlpha \ 255
         bImage(x + 1, y) = bImage(x + 1, y) * bAlpha \ 255
         bImage(x + 2, y) = bImage(x + 2, y) * bAlpha \ 255
      Next x
   Next y
   
a: ' Clear up the temporary array descriptors.  You
   ' only need to do this on NT but best to be safe.
   CopyMemory ByVal VarPtrArray(bMask), 0&, 4
   CopyMemory ByVal VarPtrArray(bImage), 0&, 4

   'lblImage.Move 2, 2
   'lblMask.Move 2, 4 + m_cAlphaImage.Height
   'lblFullAlpha.Move 2, 6 + m_cAlphaImage.Height * 2
   'lblFaded.Move 2, 8 + m_cAlphaImage.Height * 3
   'Draw
Set CreateAlphaImage = m_cAlphaImage
   
End Function

Public Function PlgBltA(ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal X1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal w As Long, ByVal h As Long, _
Optional ByVal hBmpMask As Long, Optional ByVal xMask As Long, Optional ByVal yMask As Long) As Long
Dim p(0 To 2) As POINTAPI
p(0).x = x
p(0).y = y
p(1).x = X1
p(1).y = y1
p(2).x = x2
p(2).y = y2
PlgBltA = PlgBlt(hDC, p(0), hSrcDC, xSrc, ySrc, w, h, hBmpMask, xMask, yMask)
End Function

Public Function AlphaBlendA(ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
ByVal w As Long, ByVal h As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal wSrc As Long, ByVal hSrc As Long, _
Optional ByVal useAlpha As Boolean, Optional ByVal nAlpha As Byte = 255) As Long
Dim bf As BLENDFUNCTION, l As Long
   bf.BlendOp = AC_SRC_OVER
   bf.BlendFlags = 0
   bf.SourceConstantAlpha = nAlpha
   bf.AlphaFormat = IIf(useAlpha, 1, 0)
CopyMemory l, bf, 4
AlphaBlendA = AlphaBlend(hDC, x, y, w, h, hSrcDC, xSrc, ySrc, wSrc, hSrc, l)
End Function

Public Function ImageOpEx(img1 As cAlphaDibSection, img2 As cAlphaDibSection, ByVal Style As enumOpStyle, Optional ByVal param As Long, Optional ByVal s As Single = 1) As cAlphaDibSection
On Error GoTo a
Dim img3 As New cAlphaDibSection
   img3.Create img1.Width, img1.Height
   img1.PaintPicture img3.hDC
   
   ' Point byte arrays at the image bits for ease of
   ' manipulation of the data:
   Dim tMask As SAFEARRAY2D
   Dim bMask() As Byte
   Dim tImage As SAFEARRAY2D
   Dim bImage() As Byte
    
    With tMask
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = img2.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = img2.BytesPerScanLine()
        .pvData = img2.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bMask()), VarPtr(tMask), 4
    
    With tImage
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = img3.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = img3.BytesPerScanLine()
        .pvData = img3.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
   
   Dim x As Long, y As Long
   Dim bAlpha As Long, b1 As Long, b2 As Long
   b1 = bMask(0, 0)
   For y = 0 To img3.Height - 1
      For x = 0 To img3.BytesPerScanLine - 4 Step 4 ' each item has 4 bytes: R,G,B,A
         '/////////////////////////////////////////MY CODE
         Select Case Style
         Case 0 'blend
          bAlpha = s * bMask(x, y) + bImage(x, y)
          axt bAlpha
          bImage(x, y) = bAlpha
          bAlpha = s * bMask(x + 1, y) + bImage(x + 1, y)
          axt bAlpha
          bImage(x + 1, y) = bAlpha
          bAlpha = s * bMask(x + 2, y) + bImage(x + 1, y)
          axt bAlpha
          bImage(x + 2, y) = bAlpha
          bAlpha = s * bMask(x + 3, y) + bImage(x + 2, y)
          axt bAlpha
          bImage(x + 3, y) = bAlpha
         Case 1
          If bImage(x, y) < bMask(x, y) Then bImage(x, y) = bMask(x, y)
          If bImage(x + 1, y) < bMask(x + 1, y) Then bImage(x + 1, y) = bMask(x + 1, y)
          If bImage(x + 2, y) < bMask(x + 2, y) Then bImage(x + 2, y) = bMask(x + 2, y)
          If bImage(x + 3, y) < bMask(x + 3, y) Then bImage(x + 3, y) = bMask(x + 3, y)
         Case 2
          If bImage(x, y) > bMask(x, y) Then bImage(x, y) = bMask(x, y)
          If bImage(x + 1, y) > bMask(x + 1, y) Then bImage(x + 1, y) = bMask(x + 1, y)
          If bImage(x + 2, y) > bMask(x + 2, y) Then bImage(x + 2, y) = bMask(x + 2, y)
          If bImage(x + 3, y) > bMask(x + 3, y) Then bImage(x + 3, y) = bMask(x + 3, y)
         Case 3
          bImage(x, y) = bImage(x, y) \ 2
          bImage(x + 1, y) = bImage(x + 1, y) \ 2
          bImage(x + 2, y) = bImage(x + 2, y) \ 2 'don't edit alpha channel
         Case 4
          bAlpha = 0& + bImage(x, y) + bImage(x + 1, y) + bImage(x + 2, y)
          bAlpha = (s * bAlpha) \ 3
          axt bAlpha
          bImage(x + 3, y) = bAlpha
          If param > 0 Then
           bImage(x, y) = bImage(x, y) * bAlpha \ 255 'correction
           bImage(x + 1, y) = bImage(x + 1, y) * bAlpha \ 255
           bImage(x + 2, y) = bImage(x + 2, y) * bAlpha \ 255
          End If
         Case 5
          bAlpha = 765& - bImage(x, y) - bImage(x + 1, y) - bImage(x + 2, y)
          bAlpha = (s * bAlpha) \ 3
          axt bAlpha
          bImage(x + 3, y) = bAlpha
          If param > 0 Then
           bImage(x, y) = bImage(x, y) * bAlpha \ 255 'correction
           bImage(x + 1, y) = bImage(x + 1, y) * bAlpha \ 255
           bImage(x + 2, y) = bImage(x + 2, y) * bAlpha \ 255
          End If
         Case 6
          bAlpha = bImage(x, y)
          atc bAlpha, s
          bImage(x, y) = bAlpha
          bAlpha = bImage(x + 1, y)
          atc bAlpha, s
          bImage(x + 1, y) = bAlpha
          bAlpha = bImage(x + 2, y)
          atc bAlpha, s
          bImage(x + 2, y) = bAlpha
         Case 7
          b2 = bMask(x, y) - b1
          bAlpha = bImage(x, y) + b2
          axt bAlpha
          bImage(x, y) = bAlpha
          bAlpha = bImage(x + 1, y) + b2
          axt bAlpha
          bImage(x + 1, y) = bAlpha
          bAlpha = bImage(x + 2, y) + b2
          axt bAlpha
          bImage(x + 2, y) = bAlpha
         End Select
         '/////////////////////////////////////////
      Next x
   Next y
   
a: ' Clear up the temporary array descriptors.  You
   ' only need to do this on NT but best to be safe.
   CopyMemory ByVal VarPtrArray(bMask), 0&, 4
   CopyMemory ByVal VarPtrArray(bImage), 0&, 4

   'lblImage.Move 2, 2
   'lblMask.Move 2, 4 + m_cAlphaImage.Height
   'lblFullAlpha.Move 2, 6 + m_cAlphaImage.Height * 2
   'lblFaded.Move 2, 8 + m_cAlphaImage.Height * 3
   'Draw
Set ImageOpEx = img3
   
End Function

Private Sub axt(n As Long)
If n > 255 Then n = 255
If n < 0 Then n = 0
End Sub

Private Sub atc(n As Long, ByVal x As Single)
If x > 0 Then n = n + (255 - n) * x Else n = n * (x + 1)
axt n
End Sub

Public Function RotateBltA(ByVal hDC As Long, ByVal xCenter As Long, ByVal yCenter As Long, ByVal Angle As Double, ByVal r As Double, ByVal hSrcDC As Long, ByVal x As Long, ByVal y As Long, ByVal w As Long, ByVal h As Long, ByVal xc As Long, ByVal yc As Long) As Long
Dim p(2) As POINTAPI
Dim a As Double
Dim xx As Double, yy As Double
Dim c As Double, s As Double
a = Angle * 1.74532925199433E-02
c = Cos(a)
s = Sin(a)
xx = -xc * r
yy = -yc * r
p(0).x = xCenter + Round(xx * c - yy * s)
p(0).y = yCenter + Round(xx * s + yy * c)
xx = (w - xc) * r
yy = -yc * r
p(1).x = xCenter + Round(xx * c - yy * s)
p(1).y = yCenter + Round(xx * s + yy * c)
xx = -xc * r
yy = (h - yc) * r
p(2).x = xCenter + Round(xx * c - yy * s)
p(2).y = yCenter + Round(xx * s + yy * c)
'MsgBox CStr(p(0).x) + "," + CStr(p(0).y) + "," + _
' CStr(p(1).x) + "," + CStr(p(1).y) + "," + _
' CStr(p(2).x) + "," + CStr(p(2).y) + ","
RotateBltA = PlgBlt(hDC, p(0), hSrcDC, x, y, w, h, 0, 0, 0)
End Function

Public Function PlgBlt98(ByVal hDC As Long, ByVal X1 As Long, ByVal y1 As Long, _
ByVal x2 As Long, ByVal y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal w As Long, ByVal h As Long) As Long
On Error GoTo a
'////////////xxx
MsgBox "Not available.", vbCritical
Exit Function
'////////////xxx
Dim iX As Double, iY As Double
Dim jx As Double, jy As Double
Dim k As Double
k = X1 * y2 + x2 * Y3 + X3 * y1 - x2 * y1 - X3 * y2 - X1 * Y3
iX = (Y3 + X3 * y1 - y1 - X1 * Y3) / k
iY = (X1 + X3 * y1 - X3 - X1 * Y3) / k
jx = (X1 * y2 + y1 - x2 * y1 - y2) / k
jy = (X1 * y2 + x2 - x2 * y1 - X1) / k

Dim bm As New cAlphaDibSection
Dim bm2 As New cAlphaDibSection
Dim x4 As Long, y4 As Long
x4 = x2 + X3 - X1
y4 = y2 + Y3 - y1
Dim r As RECT
r.Left = mn(X1, x2, X3, x4)
r.TOp = mn(y1, y2, Y3, y4)
r.Right = mx(X1, x2, X3, x4)
r.Bottom = mx(y1, y2, Y3, y4)
bm.Create r.Right - r.Left, r.Bottom - r.TOp
BitBlt bm.hDC, 0, 0, bm.Width, bm.Height, hDC, r.Left, r.TOp, vbSrcCopy
bm2.Create w, h
BitBlt bm2.hDC, 0, 0, w, h, hSrcDC, xSrc, ySrc, vbSrcCopy

Dim si As Double, sj As Double
Dim i As Long, j As Long
Dim ii As Double, jj As Double
Dim xx As Long, yy As Long
si = (X1 * r.TOp + r.Left * Y3 + X3 * y1 - r.Left * y1 - X3 * r.TOp - X1 * Y3) / k
sj = (X1 * y2 + x2 * r.TOp + r.Left * y1 - x2 * y1 - r.Left * y2 - X1 * r.TOp) / k

   Dim tMask As SAFEARRAY2D
   Dim bMask() As Byte
   Dim tImage As SAFEARRAY2D
   Dim bImage() As Byte
    
    With tMask
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = bm2.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = bm2.BytesPerScanLine()
        .pvData = bm2.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bMask()), VarPtr(tMask), 4
    
    With tImage
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = bm.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = bm.BytesPerScanLine()
        .pvData = bm.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(bImage()), VarPtr(tImage), 4
  For j = 0 To bm.Height - 1
   ii = si
   jj = sj
   For i = 0 To bm.Width - 1
    If ii >= 0 And ii <= 1 And jj >= 0 And jj <= 1 Then
     xx = Int(ii * (x2 - X1) + jj * (X3 - X1)) + X1 - r.Left
     yy = Int(ii * (y2 - y1) + jj * (Y3 - y1)) + y1 - r.TOp
     If xx >= 0 And yy >= 0 Then
      bImage(i, j * 4) = bMask(xx, yy * 4)
      bImage(i, j * 4 + 1) = bMask(xx, yy * 4 + 1)
      bImage(i, j * 4 + 2) = bMask(xx, yy * 4 + 2)
      bImage(i, j * 4 + 3) = bMask(xx, yy * 4 + 3)
     End If
    End If
    ii = ii + iX
    jj = jj + jx
   Next i
   si = si + iY
   sj = sj + jy
  Next j
a: ' Clear up the temporary array descriptors.  You
   ' only need to do this on NT but best to be safe.
   CopyMemory ByVal VarPtrArray(bMask), 0&, 4
   CopyMemory ByVal VarPtrArray(bImage), 0&, 4

BitBlt hDC, r.Left, r.TOp, bm.Width, bm.Height, bm.hDC, 0, 0, vbSrcCopy
End Function

Private Function mx(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) As Long
Dim n As Long
n = IIf(a > b, a, b)
n = IIf(n > c, n, c)
mx = IIf(n > d, n, d)
End Function

Private Function mn(ByVal a As Long, ByVal b As Long, ByVal c As Long, ByVal d As Long) As Long
Dim n As Long
n = IIf(a < b, a, b)
n = IIf(n < c, n, c)
mn = IIf(n < d, n, d)
End Function

Private Sub Class_Initialize()
Dim s As String * 80, Length As Long
Length = GetWindowsDirectory(s, Len(s))
WPath = Left(s, Length)
Length = GetSystemDirectory(s, Len(s))
sPath = Left(s, Length)
End Sub

Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
   If (rR > rG) Then
      If (rR > rB) Then
         Maximum = rR
      Else
         Maximum = rB
      End If
   Else
      If (rB > rG) Then
         Maximum = rB
      Else
         Maximum = rG
      End If
   End If
End Function
Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
   If (rR < rG) Then
      If (rR < rB) Then
         Minimum = rR
      Else
         Minimum = rB
      End If
   Else
      If (rB < rG) Then
         Minimum = rB
      Else
         Minimum = rG
      End If
   End If
End Function

Public Sub RGBToHLS( _
      ByVal r As Long, ByVal g As Long, ByVal b As Long, _
      h As Single, s As Single, l As Single _
   )
Dim max As Single
Dim min As Single
Dim delta As Single
Dim rR As Single, rG As Single, rB As Single

   rR = r / 255: rG = g / 255: rB = b / 255

'{Given: rgb each in [0,1].
' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
        max = Maximum(rR, rG, rB)
        min = Minimum(rR, rG, rB)
        l = (max + min) / 2    '{This is the lightness}
        '{Next calculate saturation}
        If max = min Then
            'begin {Acrhomatic case}
            s = 0
            h = 0
           'end {Acrhomatic case}
        Else
           'begin {Chromatic case}
                '{First calculate the saturation.}
           If l <= 0.5 Then
               s = (max - min) / (max + min)
           Else
               s = (max - min) / (2 - max - min)
            End If
            '{Next calculate the hue.}
            delta = max - min
           If rR = max Then
                h = (rG - rB) / delta    '{Resulting color is between yellow and magenta}
           ElseIf rG = max Then
                h = 2 + (rB - rR) / delta '{Resulting color is between cyan and yellow}
           ElseIf rB = max Then
                h = 4 + (rR - rG) / delta '{Resulting color is between magenta and cyan}
            End If
            'Debug.Print h
            'h = h * 60
           'If h < 0# Then
           '     h = h + 360            '{Make degrees be nonnegative}
           'End If
        'end {Chromatic Case}
      End If
'end {RGB_to_HLS}
End Sub

Public Sub HLSToRGB( _
      ByVal h As Single, ByVal s As Single, ByVal l As Single, _
      r As Long, g As Long, b As Long _
   )
Dim rR As Single, rG As Single, rB As Single
Dim min As Single, max As Single

   If s = 0 Then
      ' Achromatic case:
      rR = l: rG = l: rB = l
   Else
      ' Chromatic case:
      ' delta = Max-Min
      If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min Value:
         min = l * (1 - s)
      Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min Value:
         min = l - s * (1 - l)
      End If
      ' Get the Max Value:
      max = 2 * l - min
      
      ' Now depending on sector we can evaluate the h,l,s:
      If (h < 1) Then
         rR = max
         If (h < 0) Then
            rG = min
            rB = rG - h * (max - min)
         Else
            rB = min
            rG = h * (max - min) + rB
         End If
      ElseIf (h < 3) Then
         rG = max
         If (h < 2) Then
            rB = min
            rR = rB - (h - 2) * (max - min)
         Else
            rR = min
            rB = (h - 2) * (max - min) + rR
         End If
      Else
         rB = max
         If (h < 4) Then
            rR = min
            rG = rR - (h - 4) * (max - min)
         Else
            rG = min
            rR = (h - 4) * (max - min) + rG
         End If
         
      End If
            
   End If
   r = rR * 255: g = rG * 255: b = rB * 255
End Sub


Public Property Get WindowsPath()
If WPath = vbNullString Then Class_Initialize
WindowsPath = WPath
End Property

Public Property Get SystemPath()
If sPath = vbNullString Then Class_Initialize
SystemPath = sPath
End Property

Public Sub TextOutB(ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal s As String, Font As StdFont, Optional ByVal ForeColor As Long, Optional ByVal BackColor As Long, Optional ByVal isTrans As Boolean, Optional ByVal Angle As Long)
Dim f As New CLogFont
Dim h As Long
Set f.LogFont = Font
f.Rotation = Angle
If isTrans Then
 SetBkMode hDC, TRANSPARENT
Else
 SetBkMode hDC, OPAQUE '?
 SetBkColor hDC, BackColor
End If
h = SelectObject(hDC, f.Handle)
SetTextColor hDC, ForeColor
TextOut hDC, x, y, s, LenA(s)
SelectObject hDC, h
End Sub

Public Function DrawTextB(ByVal hDC As Long, ByVal s As String, Font As StdFont, ByVal Left As Long, ByVal TOp As Long, Optional Width As Long, Optional Height As Long, Optional ByVal Style As DrawTextConstants, Optional ByVal ForeColor As Long, Optional ByVal BackColor As Long, Optional ByVal isTrans As Boolean) As Long
On Error Resume Next
Dim f As New CLogFont
Dim h As Long
Dim r As RECT
Set f.LogFont = Font
If isTrans Then
 SetBkMode hDC, TRANSPARENT
Else
 SetBkMode hDC, OPAQUE '?
 SetBkColor hDC, BackColor
End If
h = SelectObject(hDC, f.Handle)
SetTextColor hDC, ForeColor
r.Left = Left
r.TOp = TOp
r.Right = Width + Left
r.Bottom = Height + TOp
DrawTextB = DrawText(hDC, s, LenA(s), r, Style)
SelectObject hDC, h
Width = r.Right - r.Left
Height = r.Bottom - r.TOp
End Function

Public Sub DrawTextWithShadow(ByVal hDC As Long, ByVal s As String, Font As StdFont, ByVal Left As Long, ByVal TOp As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, ByVal Color2 As Long, Optional ByVal offset As Long, Optional ByVal Style As DrawTextConstants)
If offset = 0 Then offset = 1
Dim f As New CLogFont
Dim h As Long
Dim r As RECT
Set f.LogFont = Font
SetBkMode hDC, TRANSPARENT
h = SelectObject(hDC, f.Handle)
SetTextColor hDC, Color2
r.Left = Left + offset
r.TOp = TOp + offset
r.Right = Width + Left + offset
r.Bottom = Height + TOp + offset
DrawText hDC, s, LenA(s), r, Style
SetTextColor hDC, Color
r.Left = Left
r.TOp = TOp
r.Right = Width + Left
r.Bottom = Height + TOp
DrawText hDC, s, LenA(s), r, Style
SelectObject hDC, h
End Sub

'Public Sub DrawTextWithShadowEx(ByVal hDC As Long, ByVal s As String, Font As StdFont, ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color As Long, ByVal Color2 As Long, Optional ByVal OffsetX As Long, Optional ByVal OffsetY As Long, Optional ByVal ShadowSize As Long, Optional ByVal Opacity As Long, Optional ByVal Style As DrawTextConstants)
'If OffsetX = 0 Then OffsetX = 1
'If OffsetY = 0 Then OffsetY = 1
'If Opacity = 0 Then Opacity = 128
'Dim f As New CLogFont
'Dim h As Long
'Dim r As RECT
'Dim bm As New cAlphaDibSection
'Dim shd As New cDIBShadowCreator
'If ShadowSize = 0 Then
' Set f.LogFont = Font
' SetBkMode hDC, TRANSPARENT
' h = SelectObject(hDC, f.Handle)
' SetTextColor hDC, Color2
' r.Left = Left + OffsetX
' r.Top = Top + OffsetY
' r.Right = Width + Left + OffsetX
' r.Bottom = Height + Top + OffsetY
' DrawText hDC, s, LenA(s), r, Style
' SetTextColor hDC, Color
' r.Left = Left
' r.Top = Top
' r.Right = Width + Left
' r.Bottom = Height + Top
' DrawText hDC, s, LenA(s), r, Style
' SelectObject hDC, h
'Else
' bm.Create Width, Height
' r.Right = Width
' r.Bottom = Height
' h = CreateSolidBrush(Color Xor vbWhite)
' FillRect bm.hDC, r, h
' DeleteObject h
' Set f.LogFont = Font
' SetBkMode bm.hDC, TRANSPARENT
' h = SelectObject(bm.hDC, f.Handle)
' SetTextColor bm.hDC, Color
' DrawText bm.hDC, s, LenA(s), r, Style
' SelectObject bm.hDC, h
' With shd
'  .TransparentColor = Color Xor vbWhite
'  .OffsetX = OffsetX
'  .OffsetY = OffsetY
'  .Opacity = Opacity
'  .ShadowColor = Color2
'  .MatrixSize = ShadowSize
'  .DibSource = bm
'  .CreateShadow
'  .DibResult.AlphaPaintPicture hDC, Left, Top, , , , , , True
' End With
'End If
'End Sub

Public Function LenA(ByVal s As String) As Long
Dim i As Long, j As Long
For i = 1 To Len(s)
 Select Case Asc(Mid(s, i, 1))
 Case Is < 0, Is > 255
  j = j + 2
 Case Else
  j = j + 1
 End Select
Next i
LenA = j
End Function

Public Function TransBltA(ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long)
TransparentBlt hDC, x, y, nWidth, nHeight, hSrcDC, xSrc, ySrc, nSrcWidth, nSrcHeight, crTransparent
End Function

'Public Sub DrawTextWithTexture(ByVal hDC As Long, ByVal s As String, Font As StdFont, ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long, ByVal hSrcDC As Long, ByVal x As Long, ByVal y As Long, Optional ByVal Style As DrawTextConstants)
'Dim f As New CLogFont
'Dim h As Long
'Dim r As RECT
'Dim bm As New cDIBSection
'Dim bm2 As New cDIBSection
'bm.Create Width, Height
'bm2.Create Width, Height
'r.Right = Width
'r.Bottom = Height
'BitBlt bm.hDC, 0, 0, Width, Height, 0, 0, 0, BLACKNESS
'Set f.LogFont = Font
'SetBkMode bm.hDC, TRANSPARENT
'h = SelectObject(bm.hDC, f.Handle)
'SetTextColor bm.hDC, vbWhite
'DrawText bm.hDC, s, LenA(s), r, Style
'SelectObject bm.hDC, h
'BitBlt bm2.hDC, 0, 0, Width, Height, hSrcDC, x, y, vbSrcCopy
'BitBlt bm2.hDC, 0, 0, Width, Height, bm.hDC, 0, 0, vbSrcAnd
'BitBlt bm.hDC, 0, 0, Width, Height, 0, 0, 0, vbDstInvert
'BitBlt hDC, Left, Top, Width, Height, bm.hDC, 0, 0, vbSrcAnd
'BitBlt hDC, Left, Top, Width, Height, bm2.hDC, 0, 0, vbSrcPaint
'End Sub

Public Function TranslateColor(ByVal oClr As OLE_COLOR, _
                        Optional hPal As Long = 0) As Long
    ' Convert Automation color to Windows color
    If OleTranslateColor(oClr, hPal, TranslateColor) Then
        TranslateColor = -1
    End If
End Function

Public Sub GradientFillRectangle( _
      ByVal lHDC As Long, _
      ByVal Left As Long, ByVal TOp As Long, ByVal Width As Long, ByVal Height As Long, _
      ByVal StartColor As Long, _
      ByVal EndColor As Long, _
      ByVal eDir As GradientFillStyle _
   )
Dim r As RECT
r.Left = Left
r.TOp = TOp
r.Right = Left + Width
r.Bottom = TOp + Height
GradientFillRect lHDC, r, StartColor, EndColor, eDir
End Sub

Public Sub ShowTextBoxBalloonTip(ByVal hWnd As Long, ByVal BalloonTipTitle As String, ByVal BalloonTipText As String, Optional ByVal BalloonTipIcon As BalloonTipIconConstants)
   Dim tEBT As EDITBALLOONTIP
   tEBT.cbStruct = LenB(tEBT)
   tEBT.pszText = StrPtr(BalloonTipText)
   tEBT.pszTitle = StrPtr(BalloonTipTitle)
   tEBT.ttiIcon = BalloonTipIcon
   SendMessage hWnd, EM_SHOWBALLOONTIP, 0, tEBT
End Sub

Public Sub HideTextBoxBalloonTip(ByVal hWnd As Long)
SendMessage hWnd, EM_HIDEBALLOONTIP, 0, ByVal 0
End Sub

Public Sub SetTextBoxCueBanner(ByVal hWnd As Long, ByVal s As String)
SendMessage hWnd, EM_SETCUEBANNER, 0, ByVal StrPtr(s)
End Sub

Public Sub SetBackColor(ByVal hDC As Long, Optional ByVal clr As Long = -1)
If clr = -1 Then
 SetBkMode hDC, TRANSPARENT
Else
 SetBkMode hDC, OPAQUE
 SetBkColor hDC, clr
End If
End Sub


